home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 March - Disc 1 / Macworld (1999-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / AlphaBits.tcl next >
Encoding:
Text File  |  1998-12-20  |  8.6 KB  |  319 lines  |  [TEXT/ALFA]
  1. # First basic initialisation: (works with Alpha 7.1 or 8.0 development)
  2. if {[catch {
  3.     if {[info tclversion] < 8.0} {
  4.     ;proc namespace {cmd ns script} {if {$script != ""} {uplevel $script}}
  5.     ;proc variable {n} { global mode ; uplevel 1 [list upvar \#0 $mode::$n $n] }
  6.     ;proc renameMenuItem {args} {}
  7.     } else {
  8.     namespace eval alpha {
  9.         namespace eval index {}
  10.         namespace eval cache {}
  11.     }
  12.     namespace eval win {}
  13.     if {[info commands scancontext] == ""} {
  14.     proc scancontext {cmd args} {
  15.         switch $cmd {
  16.         "create" {
  17.             uplevel 1 {
  18.             set __scan 0
  19.             while {[array exists scancontext$__scan]} {
  20.                 incr __scan
  21.             }
  22.             set scancontext[set __scan]() 1
  23.             return scancontext$__scan
  24.             }
  25.         }
  26.         "delete" {
  27.             upvar [lindex $args 0] scan
  28.             unset scan
  29.         }
  30.         }
  31.     }
  32.     
  33.     proc scanmatch {scanid regexp script args} {
  34.         if {[string match "-*" $scanid]} {
  35.         set flags $scanid
  36.         set scanid $regexp
  37.         set regexp [list $flags $script]
  38.         set script [lindex $args 0]
  39.         } else {
  40.         set regexp [list -- $regexp]
  41.         }
  42.         upvar $scanid scan
  43.         set scan($regexp) $script
  44.         return $scanid
  45.     }
  46.     
  47.     proc scanfile {scanid fid} {
  48.         upvar $scanid scan
  49.         upvar matchInfo m
  50.         set m(linenum) 0
  51.         set m(offset) 0
  52.         set names [array names scan]
  53.         while {[set count [gets $fid m(line)]] >= 0} {
  54.         incr m(linenum)
  55.         incr m(offset) $count
  56.         foreach reg $names {
  57.             if {$reg == ""} {continue}
  58.             if {[regexp [lindex $reg 0] [lindex $reg 1] $m(line) \
  59.               "" m(submatch0) m(submatch1) m(submatch2)]} {
  60.             uplevel 1 $scan($reg)
  61.             }
  62.         }
  63.         }
  64.     }
  65.         }
  66.     if {[info commands objDialog] != ""} {
  67.         rename dialog ""
  68.         rename objDialog dialog
  69.     }
  70.     rename lsort __lsort
  71.     proc lsort {args} {
  72.         if {[lindex $args 0] == "-ignore"} {
  73.         eval __lsort -dictionary [lrange $args 1 end]
  74.         } else {
  75.         eval __lsort $args
  76.         }
  77.     }
  78.     rename glob __glob
  79.     proc glob {args} {
  80.         if {[lindex $args 0] == "-t"} {
  81.         eval __glob [lrange $args 2 end]
  82.         } else {
  83.         eval __glob $args
  84.         }
  85.     }
  86.     # Tcl 8.0 doesn't handle \t \r \n , but Tcl 8.1 will
  87.     if {[info tclversion] == 8.0} {
  88.         rename regexp __regexp
  89.         proc regexp {args} {
  90.         set i 0
  91.         while {[string match -* [set a [lindex $args $i]]]} {
  92.             incr i
  93.             if {$a == "--"} {
  94.             set a [lindex $args $i]
  95.             break
  96.             }
  97.         }
  98.         __regsub -all "\\\\t" $a "\t" a
  99.         __regsub -all "\\\\r" $a "\r" a
  100.         __regsub -all "\\\\n" $a "\n" a
  101.         __regsub -all "\\\\w" $a "\[a-zA-Z_\]" a
  102.         uplevel __regexp [lreplace $args $i $i $a]
  103.         }
  104.         rename regsub __regsub
  105.         proc regsub {args} {
  106.         set i 0
  107.         while {[string match -* [set a [lindex $args $i]]]} {
  108.             incr i
  109.             if {$a == "--"} {
  110.             set a [lindex $args $i]
  111.             break
  112.             }
  113.         }
  114.         __regsub -all "\\\\t" $a "\t" a
  115.         __regsub -all "\\\\r" $a "\r" a
  116.         __regsub -all "\\\\n" $a "\n" a
  117.         __regsub -all "\\\\w" $a "\[a-zA-Z_\]" a
  118.         uplevel __regsub [lreplace $args $i $i $a]
  119.         }
  120.     }
  121.     }    
  122.     
  123.     # Get Alpha's current name.
  124.     regexp {"([^"]+)" "ALFA" } [processes] "" ALPHA
  125.     # PREFS points to a folder 'Alpha', we add the major version number
  126.     set alpha::version [lindex [split [string trimleft [version] "Alpha Version"] ,] 0]
  127.     set alpha::tclversion ${alpha::version}
  128.     # This patch version will eventually disappear, I think, since it is now
  129.     # considered the version of the Alpha application, and should therefore
  130.     # come from the application itself (the C code).
  131.     set alpha::patchlevel ".5"
  132.     append alpha::version ${alpha::patchlevel}
  133.     # append patch-level to Alphatcl version
  134.     set alpha::tclpatchlevel ".5"
  135.     append alpha::tclversion ${alpha::tclpatchlevel}
  136.     
  137.     if {[regexp -nocase "for (ppc|68k)" [version]] || ![regexp "for" [version]]} {
  138.     set alpha::platform "alpha"
  139.     } 
  140.     
  141.     append PREFS "-v[lindex [split ${alpha::version} .] 0]"
  142.     # useful proc
  143.     if {[info tclversion] < 7.6} { 
  144.     set tcl_platform(platform) macintosh
  145.     # Alpha already has these two renamed internally
  146.     # they need their argument packaged as a list!
  147.     ;proc mkdir {dir} {
  148.         oldMkdir [list $dir]
  149.     }
  150.     ;proc rmdir {dir} {
  151.         oldRmdir [list $dir]
  152.     }
  153.     if {[info commands __file] == ""} {
  154.         rename file __file
  155.         ;proc file {cmd args} {
  156.         switch -- $cmd {
  157.             "join" {
  158.             regsub -all "::" [set res [join $args ":"]] ":" res
  159.             return $res
  160.             }
  161.             "copy" {eval copyFile $args}
  162.             "rename" {eval moveFile $args}
  163.             "delete" {
  164.             if {[file isdir [lindex $args 0]]} {
  165.                 eval rmdir $args
  166.             } else {
  167.                 eval removeFile $args
  168.             }
  169.             }
  170.             "mkdir" {eval mkdir $args}
  171.             "volumes" {
  172.             # Thanks to Jon
  173.             return [aebuild::result 'MACS' core getd ---- {obj {form:indx, want:type(cdis), seld:abso('all '), from:'null'()}} rtyp TEXT] 
  174.             }
  175.             default {uplevel 1 __file $cmd $args}
  176.         }
  177.         }
  178.     }
  179.     } 
  180.     # check if the user over-rides things
  181.     if {[file exists [file join ${HOME} AlphaPrefs]] \
  182.       && [file isdir [file join ${HOME} AlphaPrefs]]} {
  183.     set PREFS [file join ${HOME} AlphaPrefs]
  184.     } else {        
  185.     if {![file exists $PREFS]} { file mkdir $PREFS }
  186.     }
  187.     set alpha::noMenusYet 1
  188.     # source v. important code
  189.     source [file join $HOME Tcl SystemCode library.tcl]
  190.     alpha::makeAutoPath 0 $skipPrefs
  191.     alpha::fixCoreBugs
  192.     # get known packages
  193.     catch {cache::read index::feature}
  194.     # if configuration has changed, rebuild indices
  195.     if {[alpha::checkConfiguration]} {
  196.     alertnote "I need to rebuild the package indices.\
  197.       This'll take just a few seconds."
  198.     # power-user can use 'option' to avoid the rebuild
  199.     if {!([getModifiers] & 72)} {
  200.         alpha::makeIndices
  201.     }
  202.     }
  203.  
  204.     if {[alpha::package vcompare ${alpha::version} 7.1d1] < 0} {
  205.     alertnote "This version of Alpha is too old.\
  206.       Upgrade from\
  207.       http://alpha.olm.net/ or\
  208.       ftp://ftp.ucsd.edu/alpha/ \
  209.       \r\rI'll quit now."
  210.     quit
  211.     }
  212.     # load the list of active packages from special cache
  213.     namespace eval global {}
  214.     set global::features ""
  215.     if {!$skipPrefs} {
  216.     catch {cache::read configuration}
  217.     catch {unset mode::defaultfeatures}
  218.     }
  219.     
  220. # Now do all the more complex stuff:
  221. # (from now on, avoid use of 'source'.  Prefer to use auto-loading)
  222.  
  223.     # pull in smarterSource and internationalMenus packages
  224.     # if the user activated them
  225.     set alpha::systempackages [list smarterSource internationalMenus]
  226.     if {[lsearch -exact ${global::features} smarterSource] != -1} {
  227.     alpha::package require smarterSource
  228.     }
  229.     if {[lsearch -exact ${global::features} internationalMenus] != -1} {
  230.     alpha::package require internationalMenus
  231.     }
  232.     
  233.     removeTemporaryFiles
  234.     alpha::getGlobalPreferences
  235.     alpha::getDefinitions
  236.     if {!$skipPrefs} {
  237.     # Read both scalar and array definitions from preferences folder.
  238.     alpha::readUserDefs
  239.     if [key::optionPressed] {
  240.     }
  241.     }
  242.     # define v. important keyboard variables
  243.     keys::keyboardChanged
  244.     menu::buildBasic
  245.     if ![info exists alpha::haveBasicKeys] {
  246.     alpha::basicKeyBindings
  247.     }
  248.     alpha::keyBindings
  249.     alpha::useElectricTemplates
  250.     # Read in all packages, modes and menus.
  251.     alpha::findAllPlugins
  252.     if {!$skipPrefs} {
  253.     # read preferences file
  254.     if [catch {alpha::readUserPrefs} err] {
  255.         append alpha::errorLog "\r" $err
  256.         unset err
  257.     }
  258.     }
  259.     # call anything that's attached to my keyboard.
  260.     hook::callAll keyboard $keyboard
  261.     # build all menus completely.
  262.     alpha::buildMainMenus
  263.     # insert menus
  264.     global::insertAllMenus
  265.     # Bind special keys
  266.     bind::fromArray keys::specialBindings keys::specialProcs
  267.  
  268. # if we do anything else to a menu, it must now be rebuilt
  269. unset alpha::noMenusYet
  270.  
  271. # couple of random things
  272. alpha::makeColourList
  273.  
  274. # Add to chars considered part of words.
  275. addAlphaChars {_ÄÅÇÉÑÖÜáàâäãåçéèêëíìîïñóòôöõúùûüÅØæøæß}
  276. # Call all startup hooks
  277. hook::callAll startupHook *
  278. # Alerts and readme's for the user:
  279.  
  280.     if {!$skipPrefs} {
  281.         if {![info exists readReadme] \
  282.           || ($readReadme != [alpha::package versions Alpha])} {
  283.         addDef readReadme [alpha::package versions Alpha]
  284.         edit -r [file join $HOME Help Readme]
  285.         } else {unset readReadme}
  286.         
  287.         if {[info exists alpha::readAtStartup]} {
  288.         foreach f ${alpha::readAtStartup} {
  289.             catch {edit -r $f}
  290.         }
  291.         unset alpha::readAtStartup
  292.         lappend modifiedVars alpha::readAtStartup
  293.         }
  294.     }
  295.  
  296. } err]} {
  297.     append alpha::errorLog "\r" $errorInfo
  298.     if {[dialog::yesno -y "View the error" -n "Continue" "That was a core startup error.  Alpha will probably not function correctly."]} {
  299.     dialog::alert $errorInfo
  300.     }
  301. }
  302. if {[info exists alpha::errorLog]} {
  303.     catch {
  304.     new -n "* Alpha startup error log *"
  305.     insertText ${alpha::errorLog}
  306.     unset alpha::errorLog
  307.     winReadOnly
  308.     }
  309. }
  310. # call these two procs to sort out the menu enabled state.
  311. catch {
  312.     menuEnableHook [expr {[win::Current] != ""}]
  313.     requireOpenWindowsHook 2
  314. }
  315. message "Initialization Complete"
  316.  
  317.  
  318.  
  319.